home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / MATH / NRPAS13 / FRPRMN.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-29  |  1KB  |  52 lines
  1. PROCEDURE frprmn(VAR p: glnarray; n: integer; ftol: real;
  2.        VAR iter: integer; VAR fret: real);
  3. (* Programs using routine FRPRMN must supply a
  4. FUNCTION fnc(p: glnarray):real; and a
  5. PROCEDURE dfnc(p: glnarray; VAR g: glnarray);
  6. which evaluate a function and its gradient. They must
  7. also define the type
  8. TYPE
  9.    glnarray = ARRAY [1..n] OF real;
  10. in the main routine. *)
  11. LABEL 99;
  12. CONST
  13.    itmax=200;
  14.    eps=1.0e-10;
  15. VAR
  16.    j,its: integer;
  17.    gg,gam,fp,dgg: real;
  18.    g,h,xi: glnarray;
  19. BEGIN
  20.    fp := fnc(p);
  21.    dfnc(p,xi);
  22.     FOR j := 1 TO n DO BEGIN
  23.       g[j] := -xi[j];
  24.       h[j] := g[j];
  25.       xi[j] := h[j]
  26.    END;
  27.    FOR its := 1 TO itmax DO BEGIN
  28.       iter := its;
  29.       linmin(p,xi,n,fret);
  30.       IF ((2.0*abs(fret-fp)) <= (ftol*(abs(fret)+abs(fp)+eps)))
  31.          THEN GOTO 99;
  32.       fp := fnc(p);
  33.       dfnc(p,xi);
  34.       gg := 0.0;
  35.       dgg := 0.0;
  36.       FOR j := 1 TO n DO BEGIN
  37.          gg := gg+sqr(g[j]);
  38. (*         dgg := dgg+sqr(xi[j])   *)
  39.          dgg := dgg+(xi[j]+g[j])*xi[j]
  40.       END;
  41.       IF (gg = 0.0) THEN GOTO 99;
  42.       gam := dgg/gg;
  43.       FOR j := 1 TO n DO BEGIN
  44.          g[j] := -xi[j];
  45.          h[j] := g[j]+gam*h[j];
  46.          xi[j] := h[j]
  47.       END
  48.    END;
  49.    writeln('pause in routine FRPRMN');
  50.    writeln('too many iterations'); readln;
  51. 99:   END;
  52.